home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / gsdbloo.exe / GS_DB3WK.PAS < prev    next >
Pascal/Delphi Source File  |  1992-02-24  |  14KB  |  449 lines
  1. Unit GS_dB3Wk;
  2. {------------------------------------------------------------------------------
  3.                               DBase File Builder
  4.  
  5.        Copyright (c)  Richard F. Griffin
  6.  
  7.        20 February 1992
  8.  
  9.        102 Molded Stone Pl
  10.        Warner Robins, GA  31088
  11.  
  12.        -------------------------------------------------------------
  13.        This unit creates dBase files.
  14.  
  15.        GS_dB3_Create builds a dBase III file structure and creates the .DBF
  16.        and .DBT files as necessary.  Fields are built interactively from the
  17.        screen.
  18.  
  19.        GS_dB3_Build writes a dBase III file structure and creates the .DBF
  20.        and .DBT files as necessary.  Uses a previously created table of field
  21.        descriptors.  Called as follows:
  22.  
  23. -------------------------------------------------------------------------------}
  24. interface
  25. {$D-}
  26.  
  27. Procedure GS_dB3_Build(fName : string; FTabl : pointer; n : integer);
  28. Function GS_dB3_Create(fName : string) : boolean;
  29.  
  30. implementation
  31. uses
  32.    CRT,
  33.    DOS,
  34.    GS_FileH,
  35.    GS_KeyI,
  36.    GS_Winfc,
  37.    GS_Strng,
  38.    GS_dBase;
  39.  
  40. CONST
  41.    EofMark     : Byte = $1A;          {Byte to indicate end of file}
  42.    EohMark     : Byte = $0D;          {Byte stored at end of the header}
  43.    dB3File     : Byte = $03;
  44.    dB3WithMemo : Byte = $83;
  45.  
  46. type
  47.    FldRecPtr   = ^FldRecTyp;
  48.    FldRecTyp   = array[1..GS_dBase_MaxRecField] of GS_dBase_Field;
  49.  
  50. var
  51.    FileWin,
  52.    StatWin  : GS_Wind_Objt;
  53.    InputStr       : GS_KeyI_Objt;
  54.    FCnt,
  55.    LCnt,
  56.    PCnt,
  57.    BeginFPos      : integer;
  58.    EndFPos        : integer;
  59.    FldRec         : FldRecPtr;
  60.    dFile          : file;
  61.    HeadRec        : GS_dBase_Head;
  62.    FileName       : string;
  63.    rsl,
  64.    yy, mm, dd, wd : word;             {Variables to hold GetDate values}
  65.    rl, i          : integer;          {Working variables}
  66.  
  67. function Quit_Keys : boolean;
  68. begin
  69.    if (GS_KeyI_Esc) or (GS_KeyI_Chr = Kbd_CEnd) then Quit_Keys := true
  70.       else Quit_Keys := false;
  71. end;
  72.  
  73. procedure WriteXYString(x,y,l : integer; s : string);
  74. begin
  75.    GoToXY(x,y);
  76.    write(s,'':l-length(s));
  77. end;
  78.  
  79. procedure WriteXYInteger(x,y,l,v : integer);
  80. begin
  81.    GoToXY(x,y);
  82.    write(v:l);
  83. end;
  84.  
  85.  
  86. procedure ShowFields;
  87. var
  88.    i,j : integer;
  89.    y : integer;
  90.    s : string;
  91.    c : char;
  92.    v : byte;
  93. begin
  94.    if PCnt > FCnt then
  95.    begin
  96.       FillChar(FldRec^[PCnt],32,#0);
  97.       FldRec^[PCnt].FieldType := 'C';
  98.    end;
  99.    if FCnt = 0 then exit;
  100.    ClrScr;
  101.    if FCnt < EndFPos then j := FCnt else j := EndFPos;
  102.    j := pred(BeginFPos+j);
  103.    y := 0;
  104.    for i := BeginFPos to j do
  105.    begin
  106.       inc(y);
  107.       WriteXYInteger(2,y,3,i);
  108.       CnvAscToStr(FldRec^[i].FieldName,s,11);
  109.       WriteXYString(8,y,10,s);
  110.       move(FldRec^[i].FieldType,c,1);
  111.       case c of
  112.          'C' : s := 'Character';
  113.          'D' : s := 'Date';
  114.          'L' : s := 'Logical';
  115.          'N' : s := 'Numeric';
  116.          'M' : s := 'Memo';
  117.       end;
  118.       WriteXYString(20,y,12,s);
  119.       move(FldRec^[i].FieldLen,v,1);
  120.       WriteXYInteger(33,y,6,v);
  121.       if c = 'N' then
  122.       begin
  123.          move(FldRec^[i].FieldDec,v,1);
  124.          WriteXYInteger(43,y,8,v);
  125.       end;
  126.    end;
  127. end;
  128.  
  129.  
  130. function UpDateFields : boolean;
  131. var
  132.    i,
  133.    x,
  134.    y  : integer;
  135.    t  : string;
  136.    c  : char;
  137.    v  : byte;
  138.  
  139.    procedure Get_Name;
  140.    var
  141.       i : integer;
  142.       s : string;
  143.       b : boolean;
  144.    begin
  145.       GS_Wind_SetIvMode;
  146.       CnvAscToStr(FldRec^[PCnt].FieldName,t,11);
  147.       t := TrimR(t);
  148.       repeat
  149.          b := true;
  150.          t := InputStr.EditString(t,8,y,10);
  151.          if (Quit_Keys) then exit;
  152.          t := AllCaps(t);
  153.          s := TrimR(t);
  154.          if s = '' then b := false
  155.          else
  156.          begin
  157.             for i := 1 to FCnt do
  158.             begin
  159.                CnvAscToStr(FldRec^[i].FieldName,s,11);
  160.                if (s = t) and (PCnt <> i) then b := false;
  161.             end;
  162.          end;
  163.          if (GS_KeyI_Chr in [Kbd_UpAr,Kbd_DnAr]) and (t = '') then b := true;
  164.          if not b then SoundBell(BeepTime, BeepFreq);
  165.       until (b) or ((PCnt = FCnt) and (GS_KeyI_Chr = Kbd_UpAr));
  166.       GS_Wind_SetNmMode;
  167.       WriteXYString(8,y,10,t);
  168.       CnvStrToAsc(t,FldRec^[PCnt].FieldName,11);
  169.    end;
  170.  
  171.    procedure Get_Type;
  172.    begin
  173.       WriteXYString(20,y,11,'C,D,L,M,N:');
  174.       GS_Wind_SetIvMode;
  175.       c := '?';
  176.       repeat
  177.          if c <> '?' then SoundBell(BeepTime, BeepFreq);
  178.          if PCnt <= FCnt then
  179.             move(FldRec^[PCnt].FieldType,c,1)
  180.          else c := 'C';
  181.          t := c;
  182.          t := InputStr.EditString(t,31,y,1);
  183.          if Quit_Keys then exit;
  184.          if length(t) > 0 then c := t[1] else c := ' ';
  185.          c := upcase(c);
  186.       until c in ['C','D','L','M','N'];
  187.       GS_Wind_SetNmMode;
  188.       case c of
  189.          'C' : t := 'Character';
  190.          'D' : t := 'Date';
  191.          'L' : t := 'Logical';
  192.          'N' : t := 'Numeric';
  193.          'M' : t := 'Memo';
  194.       end;
  195.       WriteXYString(20,y,12,t);
  196.       if c <> 'N' then ClrEol;
  197.       move(c,FldRec^[PCnt].FieldType,1);
  198.    end;
  199.  
  200.    procedure Get_Length;
  201.    begin
  202.       if c in ['D','L','M'] then
  203.       begin
  204.          if c = 'D' then v := 8
  205.             else if c = 'L' then v := 1
  206.                else v := 10;
  207.       end
  208.       else
  209.       begin
  210.          GS_Wind_SetIvMode;
  211.          x := 0;
  212.          v := 0;
  213.          repeat
  214.             if x <> 0 then SoundBell(BeepTime, BeepFreq);
  215.             move(FldRec^[PCnt].FieldLen,v,1);
  216.             str(v:6,t);
  217.             t := InputStr.EditString(t,33,y,6);
  218.             if Quit_Keys then exit;
  219.             val(t,v,x);
  220.             if v <= 0 then x := 1;
  221.             if v > 255 then x := 1;
  222.          until x = 0;
  223.          GS_Wind_SetNmMode;
  224.       end;
  225.       WriteXYInteger(33,y,6,v);
  226.       move(v,FldRec^[PCnt].FieldLen,1);
  227.    end;
  228.  
  229.    procedure Get_Decimal;
  230.    begin
  231.       v := 0;
  232.       GS_KeyI_Chr := Kbd_Ret;
  233.       if c = 'N' then
  234.       begin
  235.          GS_Wind_SetIvMode;
  236.          x := 0;
  237.          repeat
  238.             if x <> 0 then SoundBell(BeepTime, BeepFreq);
  239.             move(FldRec^[PCnt].FieldDec,v,1);
  240.             str(v:8,t);
  241.             t := InputStr.EditString(t,43,y,8);
  242.             if Quit_Keys then exit;
  243.             val(t,v,x);
  244.             if v < 0 then x := 1;
  245.             if v > pred(FldRec^[PCnt].FieldLen) then x := 1;
  246.          until x = 0;
  247.          GS_Wind_SetNmMode;
  248.          WriteXYInteger(43,y,8,v);
  249.       end;
  250.       move(v,FldRec^[PCnt].FieldDec,1);
  251.    end;
  252.  
  253. begin
  254.    PCnt :=succ(FCnt);
  255.    ShowFields;
  256.    repeat
  257.       LCnt := 0;
  258.       repeat
  259.          y := succ(PCnt-BeginFPos);
  260.          case LCnt of
  261.            0 : begin
  262.                   gotoxy(2,y);
  263.                   write(PCnt:3);
  264.                   GS_KeyI_Chr := ' ';
  265.                   if PCnt > FCnt then
  266.                   begin
  267.                      FillChar(FldRec^[PCnt],32,#0);
  268.                      FldRec^[PCnt].FieldType := 'C';
  269.                   end;
  270.                end;
  271.            1 : Get_Name;
  272.            2 : Get_Type;
  273.            3 : Get_Length;
  274.            4 : Get_Decimal;
  275.          end;
  276.          inc(LCnt);
  277.          case GS_KeyI_Chr of
  278.             Kbd_RTb   : begin
  279.                            dec(LCnt,2);
  280.                            if LCnt < 1 then LCnt := 1;
  281.                         end;
  282.             Kbd_UpAr  : LCnt := 5;
  283.             Kbd_DnAr  : LCnt := 5;
  284.          end;
  285.       until (LCnt > 4) or (Quit_Keys);
  286.       case GS_KeyI_Chr of
  287.          Kbd_Tab,
  288.          Kbd_Ret   : begin
  289.                         inc(PCnt);
  290.                         if PCnt > succ(FCnt) then inc(FCnt);
  291.                      end;
  292.          Kbd_UpAr  : dec(PCnt);
  293.          Kbd_DnAr  : inc(PCnt);
  294.       end;
  295.       if PCnt < 1 then PCnt := 1;
  296.       if PCnt > succ(FCnt) then PCnt := succ(FCnt);
  297.       if PCnt < BeginFPos then
  298.       begin
  299.          BeginFPos := PCnt;
  300.          ShowFields;
  301.       end;
  302.       if PCnt >= BeginFPos+EndFPos then
  303.       begin
  304.          inc(BeginFPos);
  305.          ShowFields;
  306.       end;
  307.    until Quit_Keys;
  308.    if (GS_KeyI_Chr = Kbd_Esc) or